The Original Shareware 1.1/The Original Shareware (WeMake CDs)(Volume 1.1)(CDs, Inc)(1993).iso/19/madtrb11.zip/WINWRI.PAS

Pascal/Delphi Source File | 1985-12-17 | 24KB | 1,230 lines

program window_write;    { for MS include (input,output) }

{ for MS replace # with chr(...) around the number  below }


const
  maxfields = 40;     { for now }
  ul_c      = #218;
  ll_c         = #192;
  ur_c         = #191;
  lr_c         = #217;
  v_c          = #179;
  h_c          = #196;
  maxitems     = 10;    { for menugen }
  maxwindows   = 50;
  maxevents    = 50;
  current_attribute = #7;


type
  lst  = string[80];

  lst_p  = ^lst;

  dte = record
    year : integer;
    month : integer;
    day : integer;
   end;  { dte }


   duo = array[0..1] of integer;
   quad = array[0..3] of integer;
   position = duo;
   line_type = quad;


  time_type = record
    hour : byte;
    minute : byte;
    second : byte;
   end;   { time_type }

  field = array[0..1] of lst;  { 1 for label, one for data }


  input_field_p  = ^input_field_type;

  screen_p    = ^screen_type;

  window_p    = ^window_type;

  task_p      = ^task;

  event_p =   ^event_record;


  task = record
    begin_task: task_p;
    get_info  : event_p;
    other_stuff : task_p;
    put_info  : event_p;
    end_task  : task_p;
   end;



  input_field_type =  record
     location   : position;   { relative to NW corner of window }
     data_area  : field;
     last_field : input_field_p;
     next_field : input_field_p;
    end;   { input_field }


  screen_type = record
     data_area  : array[0..maxfields] of input_field_type;
     w_p        : window_p;
     end;

  screen_type_file = file of screen_type;



  textstring_type = record
     the_text : array[0..1000] of char;
     strpos   : integer;
     len      : integer;
    end;


 window_type = record
     ulLR     : QUAD;
     job      : integer;
     s_p      : screen_p;
     text     : textstring_type;
    end;      { window_type }


  setofchar   = set of char;

  regpack = record
     ax,bx,cx,dx,bp,di,si,ds,es,flags  : integer;
  end;


  amount  = array [0..7] of char;


  event_record = record
       active_window : window_p;
       mouse_down    : boolean;
       mouse_where   : position;
       keypress      : boolean;
       key           : char;
       cursor_where  : position;
       sysreq        : byte;
       end;   { event_record }

  event_record_file = file of event_record;


  system_status_type = record
       active_window : byte;
       drives_on     : byte;  { bit coded..1 on is A:, 2 on is B:, etc }
       time          : time_type;
       date          : dte;
       cursor_where  : position;
       end;     { system_status_type }



  screen_position_pair_type = (char_byte, attr_byte);

  imagetype = array[1..25,1..80,char_byte..attr_byte] of char;


  image_p     = ^imagetype;





var
  ch , up, down, left, right, retrn, escape, home,
  endd, pgup, pgdn,f1,f2,f3,f4,f5,f6,f7,f8,f9,f10 :  char;
  i                    : integer;
  scp                  : screen_p;   { screen pointer }
  wp                   : array[1..maxwindows] of window_p;   { window pointer }
  wp_index             : integer;
  control_set          : setofchar;
  event                : event_record;
  system_status        : system_status_type;
  counter, max         : integer;
  system_okset         : setofchar;


  crtmode,page,width   : byte;
  monobuffer           : imagetype absolute $B000:$0000;
  colorbuffer          : imagetype absolute $B800:$0000;
  buffer               : imagetype;
  screen_stack         : array[0..maxwindows] of image_p;


procedure incr(var i : integer);

begin
  i := i + 1;
end;




procedure get_screen(var buffer : imagetype);

begin
    if crtmode = 7 then buffer := monobuffer else
            buffer := colorbuffer;
end;



procedure put_screen(var buffer : imagetype);

begin
    if crtmode = 7 then monobuffer := buffer else
            colorbuffer := buffer;
end;



procedure decr(var i : integer);

begin
  i := i - 1;
end;





procedure init_var;


begin
  wp_index := 0;
  escape := #27;
  retrn  := #13;
  up     := #9;
  down   := #10;
  left   := #11;
  right  := #12;
  home   := #14;
  endd   := #15;
  pgup   := #16;
  pgdn   := #17;
  f1     := #1;
  f2     := #2;
  f3     := #3;
  f4     := #4;
  f5     := #5;
  f6     := #6;
  f7     := #7;
end;   { procedure init_var }








procedure putchar(x,y : integer; ch : char);
begin
    if crtmode = 7 then monobuffer[y,x,char_byte] := ch else
            colorbuffer[y,x,char_byte] := ch;
end;





PROCEDURE PUTSTRING(xcoord, ycoord : integer;s :lst);

var
  i :integer;

begin
  for i := 1 to length(s) do putchar((xcoord + i - 1), ycoord,s[i]);
end;   { PUTSTRING }




PROCEDURE INVERSE;
 { sets current screen attribute (used by PUTSTRING) to inverse status }

BEGIN


   textcolor(black);
   textbackground(white);

END;   { inverse }





PROCEDURE NORMAL;
 { sets the current screen attribute (used by PUTSTRING) to normal status }

BEGIN


   textcolor(white);
   textbackground(black);

END;   { normal }



PROCEDURE DRAWBOX(col, line, horiz, vert : integer);

VAR
   I                    : INTEGER;
   S                    : LST;
   ul,ur,ll,lr,h,v      : char;

BEGIN  { DRAWBOX }

   UL := CHR(218); {┌}
   UR := CHR(191); {┐}
   LL := CHR(192); {└}
   LR := CHR(217); {┘ }
   H  := CHR(196); {─ }
   V  := CHR(179); {│ }



   s := '';
   for i := 1 to horiz do s:= concat(s,h);

   s := concat(ul,s,ur);
   putstring(col,line,s);


    { DRAW RIGHT VERTICAL LINE }
   FOR I := 1 TO (VERT + 1) DO
        begin


          putchar(col,(line + i),v);
          putchar((col + horiz + 1),(line + i),v);
        end;


    { DRAW BOTTOM LINE }

   s := '';
   for i := 1 to horiz do s:= concat(s,h);

   s := concat(ll,s,lr);
   putstring(col,(line + vert + 1),s);


END;   { DRAWBOX }





procedure put_box(text1, text2:lst);

const
   maxlength  = 75;

begin
  drawbox(0,20,77,2);
  if (length(text1) > maxlength) then text1 := copy(text1,1,75);
  if (length(text2) > maxlength) then text2 :=  copy(text2,1,75);
  putstring(2,21,text1);
  putstring(2,22,text2);
end;  { put_box }





PROCEDURE   SET_CURSOR_TYPE  (var start: byte; var  stop : byte);
{ use byte type as parameter so number is straight binary }

var
  recpack : regpack;

begin

 with recpack do
  begin
    ax := 1 shl 8;   { set cursor type call }
    cx := start shl 8 + stop;  { start goes into bits 4-0 of CH }
  end;

  intr($10,recpack);
end;   { set_cursor_type }






PROCEDURE   CURRENT_VIDEO_STATE
       (var page  : byte;     { parameter is modified }
        var mode  : byte;     { parameter is modified }
        var width : byte);    { parameter is modified }

var
  recpack : regpack;

begin
  with recpack do ax := 15 shl 8; {  video state request }
  intr($10,recpack);              {  int hex 10 is video services }
  with recpack do
    begin
      mode :=  ax; { actually in AL }
      width := swap(ax);  { AH }
      page  := swap(bx);  { BH }
    end;
end;   { current_video_state }









PROCEDURE RESET_CURSOR;                           { internal to SAFELIB.IMP }

 { turns cursor back to underline }

VAR
   PAGE,MODE,WIDTH,START,STOP : byte;

BEGIN  { reset_cursor }

CURRENT_VIDEO_STATE(PAGE,MODE,WIDTH); { find out what kind of monitor this is }

IF MODE = 7 THEN BEGIN                { monochrome }
   START := 12;
   STOP := 13;
END
ELSE BEGIN
   START := 7;
   STOP := 7;
END;  (* if *)
SET_CURSOR_TYPE(START,STOP);

END;   { reset_cursor }

PROCEDURE SET_CURSOR;                           { internal to SAFELIB.IMP }

 { turns cursor into large white block }

VAR
   PAGE,MODE,WIDTH,START,STOP : byte;

BEGIN  { set_cursor }

CURRENT_VIDEO_STATE(PAGE,MODE,WIDTH); { find out what kind of monitor this is }
START := 0;                           { cursor_start will be top line }
IF MODE = 7 THEN STOP := 13           { if monochrome, last line is 13 }
ELSE STOP := 7;                       { else color or graphice, last line = 7 }
SET_CURSOR_TYPE(START,STOP);          { set it }

END;   { set_cursor }




procedure zero_cursor;

var
  a,b : byte;

begin
  reset_cursor;
end;   { zereo_cursor }




function getchar(okset : setofchar; cursoron : boolean): char;


const
   prefix = #0;   { Turbo's version of chr(0) }
   BELL   = #7;


var
  ch : char;
  good   : boolean;






function getchar_detail:char;   {does the DOS call }

  type
   regpack = record
              ax,bx,cx,dx,bp,si,ds,es,flags: integer;
            end;

  var
   recpack : regpack;

  begin
     recpack.ax := $07 shl 8;
     { puts the Hex 07 call (KB input) into AH }
     MsDos(recpack);
     getchar_detail := chr(lo(recpack.ax));
     { keystroke is returned in AL -- this seems to read it ok }

  end;  { getchar_detail }


begin
  if (cursoron) then set_cursor;


  REPEAT
   ch := getchar_detail;
   IF CH = PREFIX THEN BEGIN     { prefixed key }
      ch := getchar_detail; { get next key that is sitting there }
      CASE ORD(CH) OF
         75 : ch := LEFT;
         77 : CH := RIGHT;
         72 : CH := UP;
         80 : CH := DOWN;
         59 : ch := f1;
         60 : ch := f2;
         61 : ch := f3;   {á}
         62 : ch := f4;   { í }
         63 : ch := f5;   { ó }
         64 : ch := #163;
         65 : ch := #164;
         66 : ch := #165;
         67 : ch := #174;
         68 : ch := #168;   {» }


         71 : ch := home;
         73 : ch := pgup;
         79 : ch := endd;
         81 : ch := pgdn;
         else CH := CHR(0);
      END;  { case }
   END;  { if }

  good := ch in okset;
  if not good then write(bell)
  else if (ord(ch) >= 32) and (cursoron) then write(ch);

UNTIL good;

getchar := ch;
  if (cursoron) then
reset_cursor;

end; { function getchar }


                                    { PC Specific }

{-----------end of SAFELIB procedures --------------------------------------}


procedure mouses(var m : quad);  { quad is a type, array [0..3] of integer}

const
   mouse_intr = 51;

var
  recpack   : regpack;

begin
{ with recpack do
     begin
       ax := m[1];
       bx := m[2];
       cx := m[3];
       dx := m[4];
     end;
  Intr(mouse_intr, recpack);
  with recpack do
     begin
       m[1] := ax;
       m[2] := bx;
       m[3] := cx;
       m[4] := dx;
     end; }
end; { Mouses}








procedure gettime(var time : time_type);

var
  local_time : time_type;
  recpack    : regpack;

begin
  with recpack do
   begin
     ax := $2c shl 8;   { time of day request }
   end;
   msdos(recpack);      { dos call }
 with recpack do
  begin
   local_time.second := dx shr 8;
   local_time.minute := cx mod 256;
   local_time.hour   := cx shr 8;
   with local_time do
    if hour > 12 then hour := hour - 12;

  end;

   time := local_time;
end;  { gettime }




procedure getdate(var local_date :dte);

var
  recpack    : regpack;

begin
  with recpack do
   begin
     ax := $2a shl 8;   { date request }
   end;
   msdos(recpack);      { dos call }
  with recpack do
  begin
   local_date.year  := cx;
   local_date.day   := dx mod 256;
   local_date.month := dx shr 8;
  end;
end;  { getdate }



procedure draw_window(window_pointer : window_p);

var
  x, y : integer;

begin
  with Window_pointer^ do
begin
      for y := ullr[1] to ullr[3] do
        for x := ullr[0] to ullr[2] do
            putchar(x,y,' ');

     drawbox(ullr[0],ullr[1], (ullr[2] - ullr[0]), (ullr[3] - ullr[1]) );

 end;
 end;










procedure get_event(var event : event_record);

var
  iq : quad;

begin

{event.keypress  := KeyPressed;}

{ intrinisc boolean }



event.key := getchar(system_okset,false);

if event.key = f1 then event.sysreq := 5 else    { open window }
  if event.key = f2 then event.sysreq := 6 else
    if event.key = f3 then event.sysreq := 7 else      { cut window }
      if event.key = f5 then event.sysreq := 9;     { move window around }

mouses(iq);

end;




procedure stoptest;

var
  ch : char;


begin
  write(#7);
  ch := getchar([retrn], false);
end;





procedure write_text(start : integer;var wp : window_p; event : event_record);

var
  loc : position;
    strsize : integer;
    counter : integer;
    effrs, effls : integer;


begin


  with event do
    begin
     with wp^ do
     begin
      strsize  := text.len;

      loc[0] := ullr[0] + 1;

      loc[1] := ullr[1] + 1;

      counter := start;

       repeat
         counter := counter + 1;
            if loc[1] <   ullr[3] then
                putchar(loc[0],loc[1],text.the_text[counter]);


         loc[0] := loc[0] + 1;  { x-coord }
         if loc[0] >= ullr[2] then
         begin
           loc[1] := loc[1] + 1;
           loc[0] := ullr[0] + 1;
         end;

      until (counter >= strsize) or (loc[1] > ullr[3]);

    text.strpos := counter - 1;

   end;   { with wp[wp_index]^ }

end;  { with event }

end;   { write_text }






procedure get_text(columns: integer;var event : event_record);





var
  okset : setofchar;
  temp_x:integer;
  pos : position;
  temp_buf     : lst;
  debug_lst    : lst;
  ch           : char;





begin    { get_text }


 WITH EVENT DO
  BEGIN
   with wp[wp_index]^ do
    begin

    if (key in system_okset) and (ord(key) > 31)   { add key to string, print}
       and (cursor_where[1]<=ullr[3]) and (cursor_where[0]<ullr[2])
        then
             if (cursor_where[0] >=  ullr[2]) and (cursor_where[1]<ullr[3])
                then { wrap }

                  begin
                   cursor_where[0] := ullr[0]+1;  {x_coord}
                   incr(cursor_where[1]);
                   incr(text.strpos);
                   text.the_text[text.strpos] := key;
                   putchar(cursor_where[0], cursor_where[1],key);
                   incr(cursor_where[0]);
                   incr(text.strpos);
                  end  {  wrap }

             else              { not wrap }
              if (cursor_where[1]<ullr[3]) then

                begin
                  putchar(cursor_where[0], cursor_where[1],key);

                  cursor_where[0] := cursor_where[0] + 1;
                  incr(text.strpos);
                  text.the_text[text.strpos] := key;
                end;



    if (key in [up,down,left,right]) then
      begin
        case ord(key) of
        9 :                     { UP }
           begin
             text.strpos := text.strpos - ((ullr[2]) - (ullr[0]));
             cursor_where[1] := cursor_where[1] - 1;
             if (cursor_where[1] <=  ullr[1]) then { wrap }
                      cursor_where[1] := ullr[3];

           end;



         10  : {down}
           begin
             text.strpos := text.strpos + ((ullr[2]) - (ullr[0]));
             cursor_where[1] := cursor_where[1] + 1;
             if (cursor_where[1] >  ullr[3]) then { wrap }
                      cursor_where[1] := ullr[1] + 1;
                     { should handel strpos here someday }
           end;

         11  : {left}
           begin
             text.strpos := text.strpos - 1;
             cursor_where[0] := cursor_where[0] - 1;
             if (cursor_where[0] <=  ullr[0]) then { wrap }
                      cursor_where[0] := ullr[2] - 1;
                     { should handel strpos here someday }
           end;


         12 : {right --ff?}
           begin
             text.strpos := text.strpos + 1;
             cursor_where[0] := cursor_where[0] + 1;
             if (cursor_where[0] >=  ullr[2]) then { wrap }
                      cursor_where[0] := ullr[0] + 1;
           end;
       end;   { case }
      end;    { if key in [up...}

     with text do if (strpos > len) then len := strpos;


  end;   { with wp[event_p]^. }

 end;   { with event do }

end;  { get_text }








procedure window_manage(var event : event_record);

var
  corners : quad;
  columns : integer;
  ch      : char;
  start, stop : byte;
  temp_window: window_type;   { temporary window }
  temp_buf   : imagetype;
  i          : integer;


begin
if event.sysreq = 5 then    { make window }

begin
 wp_index := wp_index + 1;    { overall layer counter }

 { save current screen }
 new(screen_stack[wp_index]);
 get_screen(buffer);
 screen_stack[wp_index]^ := buffer;

 { make new window }
 new(wp[wp_index]);

 corners[0]  := 40;
 corners[1]  := 12;

 gotoxy(corners[0],corners[1]);
 set_cursor;

 { establish NW corner of window }
repeat
   ch := getchar([retrn, right, down,left, up,home], false);
   if (ch = left) then
        corners[0] := corners[0] - 1;

   if (ch = up) then corners[1] := corners[1] - 1;
   if (ch = right) then
        corners[0] := corners[0] + 1;

   if (ch = down) then corners[1] := corners[1] + 1;
   if (ch = home) then
     begin
        corners[0] := corners[0] - 1;
        corners[1] := corners[1] - 1;
     end;

   GotoXY(corners[0],corners[1]);
 until ( ch = retrn);


 corners[2] := corners[0];
 corners[3] := corners[1];


   { get SE corner from user  -- keep showing box }
 repeat
   ch := getchar([retrn, right, down,home,endd,pgup,pgdn], false);
   if (ch = right) then
        corners[2] := corners[2] + 1;

   if (ch = down) then corners[3] := corners[3] + 1;
   if (ch = home) then
     begin
        corners[2] := corners[2] - 1;
        corners[3] := corners[3] - 1;
     end;

   if (ch = endd) then
     begin
        corners[2] := corners[2] - 1;
        corners[3] := corners[3] - 1;
     end;

   if (ch = pgup) then
     begin
        corners[2] := corners[2] + 1;
        corners[3] := corners[3] - 1;
     end;

   if (ch = pgdn) then
     begin
        corners[2] := corners[2] + 1;
        corners[3] := corners[3] + 1;
     end;


   wp[wp_index]^.ullr := corners;
   draw_window(wp[wp_index]);
 until ( ch = retrn);


 draw_window(wp[wp_index]);   { will clean inside of box }

 wp[wp_index]^.text.strpos := 0;
 wp[wp_index]^.text.len := 1;


 event.cursor_where[0] := corners[0]+1;
 event.cursor_where[1] := corners[1]+1;
     { set things up for action inside the box }


 EVENT.Active_Window := wp[wp_index];

 reset_cursor;


 end
    { if sysreq = 5 }
 else if (event.sysreq = 6) then   { zap window }
  begin
   if (wp_index > 1) then

   begin
     dispose(wp[wp_index]);                { pop window stack }
     if (crtmode = 7) then monobuffer := screen_stack[wp_index]^
         else colorbuffer := screen_stack[wp_index]^;
             { restore previous screen }
     dispose(screen_stack[wp_index]);
     decr(wp_index);
   end
  end  { if sysreq = 6 }

else if (event.sysreq = 7) then   { scroll--top window to bottom }
                                  { of stack, everybody moves up one }

  begin
    temp_buf           := screen_stack[wp_index]^;
    temp_window        := wp[wp_index]^;
               { save top of stacks }
    for i := (wp_index - 1) downto 1 do
     begin
      screen_stack[i + 1]^ := screen_stack[i]^;
      wp[i + 1]^          := wp[i]^;
     end;
        { pop the stacks }

    screen_stack[1]^ := temp_buf;
    wp[1]^          := temp_window;

    for i := 1 to wp_index do
     begin
       draw_window(wp[i]);
       write_text(1,wp[i],event);
     end;

    event.cursor_where[0] := wp[i]^.ullr[0]+1;
    event.cursor_where[1] := wp[i]^.ullr[1]+1;


  end   { = 7 }
 else if (event.sysreq = 8) then    { make window without getting coords }
begin
 wp_index := wp_index + 1;    { overall layer counter }

 { save current screen }
 new(screen_stack[wp_index]);
 get_screen(buffer);
 screen_stack[wp_index]^ := buffer;

 { make new window }
 new(wp[wp_index]);

 wp[wp_index] := event.active_window;  { get coords that are in event_record }

 draw_window(wp[wp_index]);   { will clean inside of box }

 wp[wp_index]^.text.strpos := 0;
 wp[wp_index]^.text.len := 1;


 event.cursor_where[0] := corners[0]+1;
 event.cursor_where[1] := corners[1]+1;
     { set things up for action inside the box }


 EVENT.Active_Window := wp[wp_index];


 reset_cursor;


 end
 else if event.sysreq=9 then   { move window around }

 begin
  { get keystroke, move frame }
  repeat
    with wp[wp_index]^ do begin
      ch := getchar([retrn, right, down,left, up,home], false);
      if (ch = left) then
           begin
             decr(ullr[0]); decr(ullr[2]);
           end;

      if (ch = up) then
           begin
             decr(ullr[1]); decr(ullr[3]);
           end;

      if (ch = right) then
           begin
             incr(ullr[0]); incr(ullr[2]);
           end;


      if (ch = down) then
           begin
             incr(ullr[1]); incr(ullr[3]);
           end;

      draw_window(wp[wp_index]);
    end   { with wp[wp_index]^ }
 until (ch=retrn);
    { now clear screen, redraw whole system }
    clrscr;

    for i := 1 to wp_index do
     begin
       draw_window(wp[i]);
       write_text(1,wp[i],event);
     end;

    event.cursor_where[0] := wp[i]^.ullr[0]+1;
    event.cursor_where[1] := wp[i]^.ullr[1]+1;

 end;

event.sysreq := 0;

end; {manage_window...}






procedure manage_system_okset(m_okset : setofchar);

begin end;




procedure update_system_rec(sysrec : system_status_type);


procedure show_status(sysrec : system_status_type);

const
  slash = '/';
  colon = ':';

var
  h,m,s,d,y   : string[4];
  datestr, timestr  : string[12];


begin
  with sysrec do
  begin
    str(date.day,d);
    str(date.month,m);
    str(date.year,y);
    datestr := m + slash+ d + slash + y;
    str(time.second:2,s); if s[1]=' ' then s[1] := '0';
    str(time.minute:2,m); if m[1]=' ' then m[1] := '0';
    str(time.hour:2,h); if h[1]=' ' then h[1] := '0';
    timestr := h + colon + m + colon + s ;
  end;
  drawbox(1,1,12,2);
  putstring(2,2,'        ');
  putstring(2,3,'        ');
  putstring(2,2,datestr);
  putstring(2,3,timestr);

end;



begin
with sysrec do
  begin
      getdate(sysrec.date);
      gettime(sysrec.time);
      show_status(sysrec);
      gotoxy(cursor_where[0],cursor_where[1]);

  end;
end;






procedure read_init_file;

var

  quad_file : file of quad;
  the_quad  : quad;   { TYPE QUAD is an array[0..3] of integer }



begin
  assign(quad_file,'config.dat');
  reset(quad_file);


  while not eof(quad_file) do
    begin
      read(quad_file, the_quad);
      event.sysreq := 8;
      event.active_window^.ullr := the_quad;

      window_manage(event);
    end;

end;   { read_init_file }






begin    { winwri }
  CURRENT_VIDEO_STATE(page,crtmode,width);

  counter := 0;
  init_var;
       if crtmode = 7 then buffer := monobuffer
              else buffer := colorbuffer;
{ read_init_file; }
  system_okset := [#1..#254,up,down,left,right,escape,retrn,f1,f2];
  clrscr;

 event.sysreq := 0;
  repeat
    event.sysreq := 5; { make_window }

     repeat

       window_manage(event);

       system_status.cursor_where := event.cursor_where;
       update_system_rec(system_status);

       get_event(event);

       system_status.cursor_where := event.cursor_where;
       update_system_rec(system_status);

       get_text(1,event);


    until(event.key = escape);


    manage_system_okset(system_okset);
    incr(counter);

until (counter > 0);  { indicates quit }


   reset_cursor;


  end.